{
module Main where

import Lexer
import Syntax
import Print
import Compiler
import System.Environment (getArgs)
import System.FilePath (replaceExtension)
}

%name fusion
%tokentype { Token }
%error { parseError }

%token if              { TKeyword "if" }
       else            { TSubKeyword "else" }
       elsif           { TSubKeyword "elsif" }
       unless          { TKeyword "unless" }
       def             { TKeyword "def" }
       abstract        { TKeyword "abstract" }
       static          { TKeyword "static" }
       override        { TKeyword "override" }
       while           { TKeyword "while" }
       until           { TKeyword "until" }
       for { TKeyword "for" }
       in  { TKeyword "in" }
       case { TKeyword "case" }
       when { TSubKeyword "when" }
       class { TKeyword "class" }
       interface { TKeyword "interface" }
       module { TKeyword "module" }
       do { TKeyword "do" }
       extends { TKeyword "extends" }
       implements { TKeyword "implements" }
       return { TKeyword "return" }
       function { TKeyword "function" }
       procedure { TKeyword "procedure" }
       import { TKeyword "import" }
       from { TKeyword "from" }
       require { TKeyword "require" }
       with { TKeyword "with" }
       struct { TKeyword "struct" }
       
       int             { TInt $$ }
       var             { TVar $$ }
       string          { TString $$ }
       classname       { TClass $$ }
       const           { TConst $$ }
       attr            { TAttr $$ }
       attr_static     { TStatic $$ }
       global          { TGlobal $$ }
       symbol          { TSymbol $$ }
       pattern         { TPattern $$ }
       
       '('             { TOpen '(' }
       '['             { TOpen '[' }
       '{'             { TOpen '{' }
       ')'             { TClose ')' }
       ']'             { TClose ']' }
       '}'             { TClose '}' }
       ':'             { TOp ":" }
       ';'             { TOp ";" }
       ','             { TOp "," }
       '.'             { TOp "." }
       endl            { TOp "\n" }
       space           { TOp " " }
       
       and     { TKeyword "and" }
       or      { TKeyword "or" }
       not     { TKeyword "not" }
       '='     { TOp "=" }
       '+'     { TOp "+" }
       '-'     { TOp "-" }
       '*'     { TOp "*" }
       '/'     { TOp "/" }
       '%='    { TOp "%=" }
       '~='    { TOp "~=" }
       '/='    { TOp "/=" }
       '-='    { TOp "-=" }
       '+='    { TOp "+=" }
       '|='    { TOp "|=" }
       '&='    { TOp "&=" }
       '>>='   { TOp ">>=" }
       '<<='   { TOp "<<=" }
       '*='    { TOp "*=" }
       '&&='   { TOp "&&=" }
       '||='   { TOp "||=" }
       '**='   { TOp "**=" }
       '..'    { TOp ".." }
       '...'   { TOp "..." }
       '||'    { TOp "||" }
       '&&'    { TOp "&&" }
       '<=>'   { TOp "<=>" }
       '=='    { TOp "==" }
       '==='   { TOp "===" }
       '!='    { TOp "!=" }
       '=~'    { TOp "=~" }
       '!~'    { TOp "!~" }
       '<='    { TOp "<=" }
       '<'     { TOp "<" }
       '>'     { TOp ">" }
       '>='    { TOp ">=" }
       '^'     { TOp "^" }
       '|'     { TOp "|" }
       '&'     { TOp "&" }
       '<<'    { TOp "<<" }
       '>>'    { TOp ">>" }
       '%'     { TOp "%" }
       '!'     { TOp "!" }
       '~'     { TOp "~" }
       '**'    { TOp "**" }
       '++'    { TOp "++" }
       '--'    { TOp "--" }
       '->'    { TOp "->" }
       '=>'    { TOp "=>" }

%left endl
%right ';'
%left ':' ','
%nonassoc if elsif else

%left and or
%left not
%left '=' '%=' '~=' '/=' '-=' '+=' '|=' '&=' '>>=' '<<=' '*=' '&&=' '||=' '**='
%left '..' '...'
%left '||'
%left '&&'
%right '<=>' '==' '===' '!=' '=~' '!~'
%right '<' '>' '<=' '>'
%left '^' '|'
%left '&'
%left '<<' '>>'
%left '+' '-'
%left '*' '/' '%'
%left NEG '~' '!' '++' '--'
%left '**'

%left space
%left '.' '->'
%%

SEQ   :: { HsExps }
       : SEQ1           { reverse $1 }
SEQ1   : EXP            { [$1] }
       | SEQ1 endl EXP  { $3 : $1 }

EXPS_COMMA  :: { HsExps }
            : EXPS_COMMA1         { reverse $1 }
EXPS_COMMA1 : EXP                 { [$1] }
            | EXPS_COMMA1 ',' EXP { $3 : $1 }

EXP  :: { HsExp }
      : IF                      { $1 }
      | DEF                     { $1 }
      | LOOP { $1 }
      | CASE { $1 }
      | CLASS { $1 }
      | MODULE { $1 }
      | INTERFACE { $1 }
      | STRUCT { $1 }
      | WITH { $1 }
      | CALL                    { $1 }
      | OPER                    { $1 }
      | EXPCLOSE                { $1 }
      | return EXP { HsReturn (Just $2) }
      | return     { HsReturn Nothing }
      | CLASSNAME space EXPS_COMMA { HsTypedExp $1 $3 }

NAME :: { String }
     : var { $1 }
     | classname { $1 }
     | const { $1 }
NAMES :: { [String] }
      : NAMES1 { reverse $1 }
NAMES1 :: { [String] }
       : NAME            { [$1] }
       | NAMES1 ',' NAME { $3 : $1 }

HASH_KEY   :: { HsHashKey }
           : var '=>' EXP { HsHashKey (hsSymbol $1) $3 }
HASH_KEYS  :: { [HsHashKey] }
           : HASH_KEYS1              { reverse $1 }
HASH_KEYS1 : HASH_KEY                { [$1] }
           | HASH_KEYS1 ',' HASH_KEY { $3 : $1 }
HASH       : HASH_KEYS               { HsHash $1 }

EXPCLOSE :: { HsExp }
         : '(' EXP ')'             { $2 } -- HsBrace
         | '{' SEQ '}'             { HsSequence HsSeqMultiLine $2 }
         | EXPCLOSE '[' EXP ']'    { HsArrayIndex $1 $3 }
         | EXPCLOSE '[' EXP '..' ']' { hsArrayIndex $1 $ hsUnaryOp HsOpRangeIncludeLeft $3 }
         | '[' ']'                 { HsArray [] }
         | '[' EXPS_COMMA ']'      { HsArray $2 }
         | '{' '}'                 { HsHash [] }
         | '{' HASH_KEYS '}'       { HsHash $2 }
         | LISTCOMP                { $1 }
         | require NAMES           { HsRequire $2 }
         | var                     { HsVar $1 }
         | const                   { HsVar $1 }
         | classname               { HsVar $1 }
         | attr                    { hsAttr $1 }
         | attr_static             { hsStatic $1 }
         | global                  { hsGlobal $1 }
         | symbol                  { hsSymbol $1 }
         | int                     { HsInt $1 }
         | string                  { HsString $1 }
         | pattern                 { HsPattern $1 }

OPER :: { HsExp }
      : EXP '=' EXP             { HsBinaryOp HsOpSet $1 $3 }
      | EXP '.' EXP             { HsBinaryOp HsOpMember $1 $3 }
      | EXP '+' EXP             { HsBinaryOp HsOpAdd $1 $3 }
      | EXP '-' EXP             { HsBinaryOp HsOpSub $1 $3 }
      | EXP '*' EXP             { HsBinaryOp HsOpMul $1 $3 }
      | EXP '/' EXP             { HsBinaryOp HsOpDiv $1 $3 }
      | EXP '**' EXP            { HsBinaryOp HsOpPow $1 $3 }
      | EXP '+=' EXP            { HsBinaryOp HsOpSetAdd $1 $3 }
      | EXP '-=' EXP            { HsBinaryOp HsOpSetSub $1 $3 }
      | EXP '*=' EXP            { HsBinaryOp HsOpSetMul $1 $3 }
      | EXP '||' EXP            { HsBinaryOp HsOpOr $1 $3 }
      | EXP '&&' EXP            { HsBinaryOp HsOpAnd $1 $3 }
      | EXP '==' EXP            { HsBinaryOp HsOpEq $1 $3 }
      | EXP '!=' EXP            { HsBinaryOp HsOpNotEq $1 $3 }
      | EXP '<' EXP             { HsBinaryOp HsOpLess $1 $3 }
      | EXP '>' EXP             { HsBinaryOp HsOpGreat $1 $3 }
      | EXP '<=' EXP            { HsBinaryOp HsOpLessEq $1 $3 }
      | EXP '>=' EXP            { HsBinaryOp HsOpGreatEq $1 $3 }
      | EXP '=~' EXP            { HsBinaryOp HsOpEqPat $1 $3 }
      | EXP '<=>' EXP           { HsBinaryOp HsOpComp $1 $3 }
      | EXP '===' EXP           { HsBinaryOp HsOpInRange $1 $3 }
      | EXP '!~' EXP            { HsBinaryOp HsOpNotEqPat $1 $3 }
      | EXP '..' EXP            { HsBinaryOp HsOpRangeInclude $1 $3 }
      | EXP '...' EXP           { HsBinaryOp HsOpRangeExclude $1 $3 }
      | EXP ';' EXP             { hsConcat $1 $3 }
      | EXP and EXP             { HsBinaryOp HsOpWordAnd $1 $3 }
      | EXP or EXP              { HsBinaryOp HsOpWordOr $1 $3 }
      | EXP '/=' EXP            { HsBinaryOp HsOpSetDiv $1 $3 }
      | EXP '**=' EXP           { HsBinaryOp HsOpSetPow $1 $3 }
      | EXP '%=' EXP            { HsBinaryOp HsOpSetMod $1 $3 }
      | EXP '~=' EXP            { HsBinaryOp HsOpSetPat $1 $3 }
      | EXP '||=' EXP           { HsBinaryOp HsOpSetOr $1 $3 }
      | EXP '&&=' EXP           { HsBinaryOp HsOpSetAnd $1 $3 }
      | EXP '|=' EXP            { HsBinaryOp HsOpSetBitOr $1 $3 }
      | EXP '&=' EXP            { HsBinaryOp HsOpSetBitAnd $1 $3 }
      | EXP '>>=' EXP           { HsBinaryOp HsOpSetShiftLeft $1 $3 }
      | EXP '<<=' EXP           { HsBinaryOp HsOpSetShiftRight $1 $3 }
      | EXP '%' EXP             { HsBinaryOp HsOpMod $1 $3 }
      | EXP '|' EXP             { HsBinaryOp HsOpBitOr $1 $3 }
      | EXP '^' EXP             { HsBinaryOp HsOpBitXOr $1 $3 }
      | EXP '&' EXP             { HsBinaryOp HsOpBitAnd $1 $3 }
      | EXP '>>' EXP            { HsBinaryOp HsOpShiftRight $1 $3 }
      | EXP '<<' EXP            { HsBinaryOp HsOpShiftLeft $1 $3 }
      | EXP '->' var            { HsBinaryOp HsOpHashMember $1 (hsSymbol $3) }
      | '-' EXP %prec NEG       { HsUnaryOp HsOpNegate $2 }
      | '!' EXP                 { HsUnaryOp HsOpNot $2 }
      | '~' EXP                 { HsUnaryOp HsOpBitNot $2 }
      | '++' EXP                { HsUnaryOp HsPreIncrement $2 }
      | EXP '++'                { HsUnaryOp HsPostIncrement $1 }
      | '--' EXP                { HsUnaryOp HsPreDecrement $2 }
      | EXP '--'                { HsUnaryOp HsPostDecrement $1 }
      | not EXP                 { HsUnaryOp HsOpWordNot $2 }

CALL      : METHODNAME space CALLARGS BLOCK { HsCall (hsMethodName $1) $3 (Just $4) }
          | METHODNAME space CALLARGS       { HsCall (hsMethodName $1) $3 Nothing }
          | METHODNAME BLOCK                { HsCall (hsMethodName $1) [] (Just $2) }
CALLARGS  : CALLARGS1 space HASH     { reverse $1 ++ [$3] }
          | CALLARGS1                { reverse $1 }
          | HASH                     { [$1] }
CALLARGS1 : EXPCLOSE                 { [$1] }
          | CALLARGS1 space EXPCLOSE { $3 : $1 }
METHODNAME :: { HsMethodName }
           : var { $1 }
BLOCK :: { HsCallBlock }
      : do BLOCKVARS ':' EXP { HsCallBlock (reverse $2) $4 }
BLOCKVARS :: { [String] }
          :                   { [] }
          | var               { [$1] }
          | BLOCKVARS ',' var { $3 : $1 }

EXPOPT :: { HsExp }
       : { hsEmpty }
       | ':' EXP { $2 }

DEF      :: { HsExp }
         : DEFOPT DEFKIND METHODNAME DEFARGSOPT EXPOPT { hsMethod' $1 $2 $3 $4 $5 }
         | abstract DEFKIND METHODNAME DEFARGSOPT      { hsMethod' HsOptAbstract $2 $3 $4 hsEmpty }
DEFOPT   :: { HsMethodOption }
         :          { HsOptNone }
         | static   { HsOptStatic }
         | override { HsOptOverride }
DEFKIND  :: { HsMethodKind }
         : function TYPE { HsMethodFunction $2 }
         | procedure     { HsMethodProcedure }
DEFARGSOPT :: { Maybe HsMethodArgs }
           :         { Nothing }
           | DEFARGS { Just $1 }
DEFARGS :: { HsMethodArgs }
        : '(' DEFARGS1 ')' { reverse $2 }
DEFARGS1 :: { HsMethodArgs }
         : DEFARG              { [$1] }
         | DEFARGS1 ',' DEFARG { $3 : $1 }
DEFARG :: { HsMethodArg }
       : TYPE var         { HsMethodArg $2 Nothing $1 }
       | TYPE var '=' EXP { HsMethodArg $2 (Just $4) $1 }
TYPE :: { Maybe HsVarType }
     :                 { Nothing }
     | CLASSNAME space { Just $1 }

ALTKIND :: { HsAltKind }
        : if     { HsIf }
        | unless { HsUnless }
IF    :: { HsExp }
      : ALTKIND EXP ':' EXP ELSIF ELSE { HsAlt $1 (hsCondExp $2 $4 : reverse $5) $6 }
ELSIF :: { [HsCondExp] }
      :                         { [] }
      | elsif EXP ':' EXP       { [hsCondExp $2 $4] }
      | ELSIF elsif EXP ':' EXP { hsCondExp $3 $5 : $1 }
ELSE  :: { Maybe HsExp }
      :              { Nothing }
      | else ':' EXP { Just $3 }

LOOP :: { HsExp }
     : while EXP ':' EXP      { hsWhile $2 $4 }
     | until EXP ':' EXP      { hsUntil $2 $4 }
     | for EXP in EXP ':' EXP { hsFor $2 $4 $6 }

CASE :: { HsExp }
     : case OPTEXP WHENS ELSE { hsCase $2 (reverse $3) $4 }
WHENS :: { [HsCondExp] }
      : when EXPS_COMMA ':' EXP       { [hsCondsExp $2 $4] }
      | WHENS when EXPS_COMMA ':' EXP { hsCondsExp $3 $5 : $1 }

OPTEXP :: { Maybe HsExp }
       :     { Nothing }
       | EXP { Just $1 }

CLASS :: { HsExp }
      : class CLASSNAME DEFARGSOPT EXTENDS IMPLEMENTS EXPOPT { hsClass $2 $3 $4 $5 $6 }
CLASSNAME :: { String }
          : classname { $1 }
          | const     { $1 }
EXTENDS :: { Maybe HsClassName }
        :                   { Nothing }
        | extends CLASSNAME { Just $2 }
IMPLEMENTS :: { [HsInterfaceName] }
           :                          { [] }
           | implements IMPLEMENTSARG { reverse $2 }
IMPLEMENTSARG :: { [HsInterfaceName] }
              : CLASSNAME                   { [$1] }
              | IMPLEMENTSARG ',' CLASSNAME { $3 : $1 }

LISTCOMP   ::                                { HsExp }
           : '[' EXP LISTFORS LISTFILTER ']' { HsListComprehension $2 (reverse $3) $4 }
LISTFORS   ::                        { [(HsExp, HsExp)] }
           : for EXP in EXP          { [($2, $4)] }
           | LISTFORS for EXP in EXP { ($3, $5) : $1 }
LISTFILTER ::       { Maybe HsExp }
           :        { Nothing }
           | if EXP { Just $2 }

MODULE :: { HsExp }
       : module CLASSNAME ':' EXP { hsModule $2 $4 }

INTERFACE :: { HsExp }
       : interface CLASSNAME ':' EXP { HsBlock (HsInterface $2) $4 }

WITH :: { HsExp }
     : with EXP ':' EXP { HsWith $2 $4 }

STRUCT :: { HsExp }
       : struct CLASSNAME DEFARGS { hsStruct $2 $3 }

{
parseError :: [Token] -> a
parseError tokens = error ("Parse error: ..." ++ showTokens (take 20 tokens) ++ "...")

fusion' :: String -> HsExp
fusion' = HsSequence HsSeqMultiLine . fusion . fusionLexer

compileFusion :: FilePath -> IO ()
compileFusion src = 
  do hsrc <- readFile src
     let out = prettyExp $ compile $ fusion' hsrc -- show $ fusionLexer hsrc
     writeFile dst out
     putStrLn $ "wrote " ++ dst ++ ": "
     putStrLn out
  where
    dst = replaceExtension src ".rb"

main :: IO ()
main = 
  do [arg] <- getArgs
     compileFusion arg
}